#lang racket


(require "generic-backend.rkt"
         "shape.rkt")

(provide proxy-backend%)


(define (shape-ids shapes)
  (flatten (map shape-id shapes)))


(define proxy-backend%
  (class* generic-backend% ()
    (super-new)
    
    (init-field evaluator)
    (init-field proxy)
    

    ; evaluate
    
    (define/override (evaluate-node node)
      (send evaluator evaluate node))
    
    (define/public (get-cached-shapes)
      (send evaluator get-cached-shapes))

    
    ; shapes
    
    (define/override (bbox shape)
      (define (bbox-proxy id)
        (send proxy bbox id))
      
      (match shape
        ((simple-shape _ _ id) (bbox-proxy id))
        ((list-shape _ _ _) (error 'bbox))))
    
    (define/public (shapes-loc file p)
      (send evaluator shapes<-srcloc file p))
    
    
    ; points
    
    (define/override (point c)
      (make-simple-shape (send proxy point c)))
    
    (define/override (point? shape)
      (define (point?-proxy id)
        (send proxy point? id))
      
      (match shape
        ((simple-shape _ _ id) (point?-proxy id))
        ((list-shape _ _ _) #f)))
    
    (define/override (point-c shape)
      (define (point-c-proxy id)
        (send proxy point-c id))
      
      (match shape
        ((simple-shape _ _ id) (point-c-proxy id))
        ((list-shape _ _ _) (error 'point-c))))
    
    
    ; lines
    
    (define/override (arc angle radius)
      (make-simple-shape (send proxy arc angle radius)))
    
    (define/override (elliptical-arc angle x-radius y-radius)
      (make-simple-shape (send proxy elliptical-arc angle x-radius y-radius)))
    
    (define/override (ellipse x-radius y-radius)
      (make-simple-shape (send proxy ellipse x-radius y-radius)))
    
    (define/override (line closed? coords)
      (make-simple-shape (send proxy line closed? coords)))
    
    (define/override (nurbs-curve controls knots)
      (make-simple-shape (send proxy nurbs-curve controls knots)))
    
    (define/override (spline closed? cs type)
      (make-simple-shape (send proxy spline closed? cs type)))
    
    (define/override (line? shape)
      (define (line?-proxy id)
        (send proxy line? id))
      
      (match shape
        ((simple-shape _ _ id) (line?-proxy id))
        ((list-shape _ _ _) (error 'line?))))
    
    (define/override (line-closed? shape)
      (define (line-closed?-proxy id)
        (send proxy line-closed? id))
      
      (match shape
        ((simple-shape _ _ id) (line-closed?-proxy id))
        ((list-shape _ _ _) (error 'line-closed?))))
    
    (define/override (polygonal-line? shape)
      (define (polygonal-line?-proxy id)
        (send proxy polygonal-line? id))
      
      (match shape
        ((simple-shape _ _ id) (polygonal-line?-proxy id))
        ((list-shape _ _ _) (error 'polygonal-line?))))
    
    (define/override (line-begin-c shape)
      (define (line-begin-c-proxy id)
        (send proxy line-begin-c id))
      
      (match shape
        ((simple-shape _ _ id) (line-begin-c-proxy id))
        ((list-shape _ _ _) (error 'line-begin-c))))
    
    (define/override (line-cs shape)
      (define (line-cs-proxy id)
        (send proxy line-cs id))
      
      (match shape
        ((simple-shape _ _ id) (line-cs-proxy id))
        ((list-shape _ _ _) (error 'line-cs))))
    
    (define/override (line-end-c shape)
      (define (line-end-c-proxy id)
        (send proxy line-end-c id))
      
      (match shape
        ((simple-shape _ _ id) (line-end-c-proxy id))
        ((list-shape _ _ _) (error 'line-end-c))))
    
    ; surfaces
    (define/override (donut inner-radius outer-radius)
      (make-simple-shape (send proxy donut inner-radius outer-radius)))
    
    (define/override (ngon width sides)
      (make-simple-shape (send proxy ngon width sides)))
    
    (define/override (nurbs-surface controls u-knots v-knots)
      (make-simple-shape (send proxy nurbs-surface controls u-knots v-knots)))
    
    (define/override (star width sides stride)
      (make-simple-shape (send proxy star width sides stride)))
    
    (define/override (surface shape/cs)
      (define (surface-proxy id/ids/cs)
        (send proxy surface id/ids/cs))
      
      (match shape/cs
        ((simple-shape _ _ id) (make-simple-shape (surface-proxy id)))
        ((list-shape _ _ shapes) (make-simple-shape (surface-proxy (shape-ids shapes))))
        (_ (make-simple-shape (surface-proxy shape/cs)))))
    
    (define/override (surface? shape)
      (define (surface?-proxy id)
        (send proxy surface? id))
      
      (match shape
        ((simple-shape _ _ id) (surface?-proxy id))
        ((list-shape _ _ _) (error 'surface?))))
    
    (define/override (surface-curvature shape)
      (define (surface-curvature-proxy id)
        (send proxy surface-curvature id))
      
      (match shape
        ((simple-shape _ _ id) (surface-curvature id))
        ((list-shape _ _ _) (error 'surface-curvature))))
    
    (define/override (surface-domain shape)
      (define (surface-domain-proxy id)
        (send proxy surface-domain id))
      
      (match shape
        ((simple-shape _ _ id) (surface-domain-proxy id))
        ((list-shape _ _ _) (error 'surface-domain))))
    
    
    ; solids
    
    (define/override (box width length height)
      (make-simple-shape (send proxy box width length height)))
    
    (define/override (cone radius height)
      (make-simple-shape (send proxy cone radius height)))
    
    (define/override (cone-frustum base-radius top-radius height)
      (make-simple-shape (send proxy cone-frustum base-radius top-radius height)))
    
    (define/override (cylinder radius height)
      (make-simple-shape (send proxy cylinder radius height)))
    
    (define/override (pyramid width sides height)
      (make-simple-shape (send proxy pyramid width sides height)))
    
    (define/override (sphere radius)
      (make-simple-shape (send proxy sphere radius)))
    
    (define/override (solid? shape)
      (define (solid?-proxy id)
        (send proxy solid? id))
      
      (match shape
        ((simple-shape _ _ id) (solid?-proxy id))
        ((list-shape _ _ _) (error 'solid?))))
    
    
    ; generic shapes
    
    (define/override (circle c type radius)
      (make-simple-shape (send proxy circle c type radius)))
    
    (define/override (rectangle type width length)
      (make-simple-shape (send proxy rectangle type width length)))
    
    
    ; text
    
    (define/override (text t r s str)
      (make-simple-shape (send proxy text t r s str)))
    
    
    ; transformations
    
    (define/override (extrude length dir shape)
      (define (extrude-proxy id)
        (send proxy extrude length dir id))
      
      (match shape
        ((simple-shape _ _ id) (make-simple-shape (extrude-proxy id)))
        ((list-shape _ _ _) (error 'extrude))))
    
    (define/override (intersect shape)
      (define (intersect-proxy ids)
        (send proxy intersect ids))
      
      (match shape
        ((empty-shape _ _) shape)
        ((universal-shape _ _) shape)
        ((simple-shape _ _ _) shape)
        ((list-shape _ _ shapes) (make-simple-shape (intersect-proxy (shape-ids shapes))))))
    
    (define/override (join shape)
      (define (join-proxy ids)
        (send proxy join ids))
      
      (match shape
        ((simple-shape _ _ _) shape)
        ((list-shape _ _ shapes) (make-simple-shape (join-proxy (shape-ids shapes))))))
    
    (define/override (loft loft-type loft-fit-type closed? shape)
      (define (loft-proxy ids)
        (send proxy loft loft-type loft-fit-type closed? ids))
      
      (match shape
        ((simple-shape _ _ _) shape)
        ((list-shape _ _ shapes) (make-simple-shape (loft-proxy (shape-ids shapes))))))
    
    (define/override (move position shape)
      (define (move-proxy id)
        (send proxy move position id))
      
      (map-shape-id move-proxy shape))
    
    (define/override (offset distance shape)
      (define (offset-proxy id)
        (send proxy offset distance id))
      
      (map-shape-id offset-proxy shape))
    
    (define/override (rotate angle normal shape)
      (define (rotate-proxy id)
        (send proxy rotate angle normal id))
      
      (map-shape-id rotate-proxy shape))
    
    (define/override (scale type c shape)
      (define (scale-proxy id/ids)
        (send proxy scale type c id/ids))
      
      (map-shape-id scale-proxy shape))
    
    (define/override (section type plane shape)
      (define (section-proxy plane-id id)
        (send proxy section type plane-id id))
      
      (match shape
        ((simple-shape _ _ id) 
         (match plane
           ((simple-shape _ _ plane-id) (make-simple-shape (section-proxy plane-id id)))
           ((list-shape _ _ _) (error 'section))))
        ((list-shape _ _ _) (error 'section))))
    
    (define/override (slice shape1 shape2)
      (define (slice-proxy id1 id2)
        (send proxy slice id1 id2))
      
      (match shape1
        ((simple-shape _ _ id1)
         (match shape2
           ((simple-shape _ _ id2) (make-list-shape (map make-simple-shape (slice-proxy id1 id2))))
           ((list-shape _ _ _) (error 'slice))))
        ((list-shape _ _ _) (error 'slice))))
    
    (define/override (subtract shape)
      (define (subtract-proxy ids)
        (send proxy subtract ids))
      
      (match shape
        ((simple-shape _ _ _) shape)
        ((list-shape _ _ shapes) (make-simple-shape (subtract-proxy (shape-ids shapes))))))
    
    (define/override (sweep path shape)
      (define (sweep-proxy path-id id)
        (send proxy sweep path-id id))
      
      (match path
        ((simple-shape _ _ path-id) (map-shape-id (λ (id) (sweep-proxy path-id id)) shape))
        ((list-shape _ _ _) (error 'sweep))))
    
    (define/override (thicken distance shape)
      (define (thicken-proxy id)
        (send proxy thicken distance id))
      
      (map-shape-id thicken-proxy shape))
    
    (define/override (union shape)
      (define (union-proxy ids)
        (send proxy union ids))
      
      (match shape
        ((simple-shape _ _ _) shape)
        ((list-shape _ _ shapes) (make-simple-shape (union-proxy (shape-ids shapes))))))
    
    
    ; lang
    
    (define/override (align key-align-types key-shape shape-align-types shape)
      (define (align-proxy id)
        (send proxy align key-align-types (shape-id key-shape) shape-align-types id))
      
      (match key-shape
        ((simple-shape _ _ _) (map-shape-id align-proxy shape))
        ((list-shape _ _ _) (error 'align))))
    
    (define/override (parametric functional-par)
      (make-simple-shape (send proxy parametric functional-par)))
    
    (define/override (lift proc shape)
      (proc)
      shape)
    
    (define/override (on type shape)
      (define (on-proxy ids)
        (send proxy on type ids))
      
      (match shape
        ((simple-shape _ _ _) (error 'on))
        ((list-shape _ _ shapes) (make-list-shape (map make-simple-shape (on-proxy (shape-ids shapes)))))))
    
    (define/override (par shape)
      (define (par-proxy id)
        (send proxy par id))
      
      (match shape
        ((simple-shape _ _ id) (par-proxy id))
        ((list-shape _ _ _) (error 'par))))
    
    
    ; cad
    (define/override (clone-shape shape)
      (define (clone-shape-proxy id)
        (send proxy clone-shape id))
      
      (map-shape-id clone-shape-proxy shape))
    
    (define/override (clone-shapes shapes)
      (define (clone-shapes-proxy ids)
        (send proxy clone-shapes ids))
      
      (map (λ (shape) (send this clone-shape shape)) shapes))
    
    (define/override (delete-shape shape)
      (define (delete-shape-proxy id)
        (send proxy delete-shape id))
      
      (for-each-shape-id delete-shape-proxy shape))
    
    (define/override (delete-shapes)
      (send proxy delete-shapes))
    
    (define/override (get-shapes)      
      (for/list ((id (send proxy get-shapes)))
        (send evaluator shape<-id id)))
    
    (define/override (layer name shape)
      (define (layer-proxy id)
        (send proxy layer name id))
      
      (map-shape-id layer-proxy shape))
    
    (define/override (prompt-point message)
      (send proxy prompt-point message))
    
    (define/override (prompt-shape message)
      (send evaluator shape<-id (send proxy prompt-shape message)))
    
    (define/override (render-shapes width height path type)
      (send proxy render-shapes width height path type))
    
    (define/override (select-shape shape)
      (define (select-shape-proxy id)
        (send proxy select-shape id))
      
      (for-each-shape-id select-shape-proxy shape))
    
    (define/override (select-shapes shapes)
      (for-each (λ (shape) (send this select-shape shape)) shapes))
    
    (define/override (unselect-all-shapes)
      (send proxy unselect-all-shapes))
    
    (define/override (view type projection-type style shape)
      (define (view-proxy id/ids)
        (send proxy view type projection-type style id/ids))
      
      (match shape
        ((simple-shape _ _ id) (make-simple-shape (view-proxy id)))
        ((list-shape _ _ shapes) (make-list-shape (map make-simple-shape (view-proxy (shape-ids shapes)))))))
    
    (define/override (valid-shape? shape)
      (define (valid-shape?-proxy id)
        (send proxy valid-shape? id))

      (match shape
        ((simple-shape _ _ id) 
         (valid-shape?-proxy id))
        ((list-shape _ _ shapes) 
         (andmap (λ (shape) (send this valid-shape? shape)) shapes))))))